home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
BBS Toolkit
/
BBS Toolkit.iso
/
wildcat
/
digikit.zip
/
APDIGI.PAS
next >
Wrap
Pascal/Delphi Source File
|
1992-07-16
|
19KB
|
756 lines
{$S-,R-,V-,I-,B-,F+,O+,A-,D+,L+}
{$I APDEFINE.INC}
{*********************************************************}
{* APDIGI.PAS 1.04 *}
{* Copyright (c) Mustang Software 1992. *}
{* All rights reserved. *}
{*********************************************************}
unit ApDigi;
interface
uses
Dos,
{$IFDEF UseOpro}
OpInline,
OpRoot,
{$ENDIF}
{$IFDEF UseTpro}
TpCrt,
TpInline,
TpMemChk,
{$ENDIF}
ApMisc,
ApPort;
{#Z+}
procedure dInitPort(var P : PortRecPtr; ComName : ComNameType;
Baud : LongInt;
Parity : ParityType; DataBits : DataBitType;
StopBits : StopBitType;
InSize, OutSize : Word;
Options : Word);
{-Open digi port}
procedure dInitPortKeep(var P : PortRecPtr; ComName : ComNameType;
InSize, OutSize : Word);
{-Open digi port (without changing line params)}
procedure dDonePort(var P : PortRecPtr);
{-Closes digi port ComName}
procedure dSetUart(ComName : ComNameType; NewBase : Word;
NewIrq, NewVector : Byte);
{-Dummy routine required by high-level routines}
procedure dSetLine(P : PortRecPtr; Baud : LongInt; Parity : ParityType;
DataBits : DataBitType; StopBits : StopBitType);
{-Sets the digi and the port record with the new values}
procedure dGetLine(P : PortRecPtr; var Baud : LongInt;
var Parity : ParityType;
var DataBits : DataBitType;
var StopBits : StopBitType;
FromHardware : Boolean);
{-Gets the line params directly from the digi}
procedure dSetModem(P : PortRecPtr; DTR, RTS : Boolean);
{-Sets the port record with the new values}
procedure dGetModem(P : PortRecPtr; var DTR, RTS : Boolean);
{-Gets the DTR,RTS settings directly from the digi}
procedure dGetChar(P : PortRecPtr; var C : Char);
{-Returns C (sets error if none available)}
procedure dPeekChar(P : PortRecPtr; var C : Char; PeekAhead : Word);
{-Looks ahead PeekAhead chars (with 1 being the next character)}
procedure dPutChar(P : PortRecPtr; C : Char);
{-Adds char to xmit buffer or outputs in directly}
procedure dStartTransmitter(P : PortRecPtr);
{-Does nothing (but required by some high-level routines)}
function dCharReady(P : PortRecPtr) : Boolean;
{-Returns True if digi status call shows a character waiting}
function dTransReady(P : PortRecPtr) : Boolean;
{-Returns True if digi status call shows room in output buffer}
function dGetLineStatusDirect(P : PortRecPtr) : Byte;
procedure dSendBreak(P : PortRecPtr);
{-Sends a serial line break}
procedure dActivatePort(P : PortRecPtr; Restore : Boolean);
{-Initializes the digi port}
procedure dDeactivatePort(P : PortRecPtr; Restore : Boolean);
{-Deactivates the digi port}
procedure dSavePort(P : PortRecPtr; var PSR);
{-Does nothing }
procedure dRestorePort(P : PortRecPtr; var PSR);
{-Does nothing }
procedure dGotError(P : PortRecPtr; StatusCode : Word);
{-Called when an error occurs (GotError calls the optional ErrorHandler)}
{#Z-}
procedure ActivateApDigi;
{-Registers this unit as the active "device layer"}
implementation
const
ecCCBTimeOut = 9980; {DigiChannel driver timed out on CCB command}
type
BytePtr = ^Byte;
OS = record
O : Word;
S : Word;
end;
var
CharReadyPtr : BytePtr;
procedure dInitPortKeep(var P : PortRecPtr; ComName : ComNameType;
InSize, OutSize : Word);
var
Found : Boolean;
I : Byte;
PWord : Word;
DTR, RTS : Boolean;
label
ErrorExit;
begin
AsyncStatus := ecOk;
if not GetMemCheck(P, SizeOf(PortRec)) then
begin
AsyncStatus := ecOutOfMemory;
Exit;
end;
{$IFDEF LargeComNameSet}
if ComName > Com8 then
begin
AsyncStatus := ecOutOfRange;
goto ErrorExit;
end;
{$ENDIF}
with P^ do
begin
PortName := ComName;
Found := False;
I := 1;
while not Found and (I <= MaxActivePort) do
if ActiveComPort[I] = nil then
begin
CurrentPort := I;
ActiveComPort[I] := P;
Found := True;
end
else
Inc(I);
if not Found then
begin
AsyncStatus := ecNoMorePorts;
goto ErrorExit;
end;
SWFState := False;
SWFGotXoff := False;
SWFSentXoff := False;
SWFOnChar := DefaultXonChar;
SWFOffChar := DefaultXoffChar;
HWFRecHonor := 0;
HWFTransHonor := 0;
HWFRemoteOff := False;
LastXmitError := 0;
Buffered := False;
InBuff := nil;
InHead := nil;
InTail := nil;
InBuffEnd := nil;
InBuffLen := 65535;
InBuffCount := 0;
OutBuff := nil;
OutHead := nil;
OutTail := nil;
OutBuffEnd := nil;
OutBuffLen := 65535;
OutBuffCount := 0;
UseStatusBuffer := False;
StatBuff := nil;
StatHead := nil;
StatTail := nil;
Flags := DefPortOptions;
BreakReceived := False;
TxReady := True;
TxInts := True;
TxIntsActive := False;
LostCharCount := 0;
DoneProc := dDonePort;
ErrorProc := NoErrorProc;
ErrorData := nil;
UserAbort := NoAbortProc;
ProtocolActive := False;
ISRActive := False;
dGetLine(P, CurBaud, CurParity, CurDataBits, CurStopBits, True);
dGetModem(P, DTR, RTS);
PWord := Word(P^.PortName);
asm
mov ah,$1E {turn CTR/RTS on}
mov bh,$00
mov bl,$12
mov dx,PWord
int $14
mov ah,$0D {get char ready ptr}
mov dx,PWord
int $14
mov word ptr CharReadyPtr,bx
mov word ptr CharReadyPtr+2,es
mov ah,$09 {flush buffers, necessary to kick char ready flag}
mov dx,PWord {on some Digicards, and to get full transmit buffer}
int $14 {space in next call}
mov ah,$12 {get transmit buffer size}
mov dx,PWord
int $14
inc ax
les di,P
les di,es:[di]
mov es:[di].PortRec.OutBuffLen,ax
end;
Exit;
end;
ErrorExit:
FreeMemCheck(P, SizeOf(PortRec));
end;
procedure dInitPort(var P : PortRecPtr; ComName : ComNameType;
Baud : LongInt;
Parity : ParityType; DataBits : DataBitType;
StopBits : StopBitType; InSize, OutSize : Word;
Options : Word);
var
B : Boolean;
begin
dInitPortKeep(P, ComName, InSize, OutSize);
if AsyncStatus <> ecOk then
Exit;
with P^ do
begin
dSetLine(P, Baud, Parity, DataBits, StopBits);
if AsyncStatus <> ecOk then
begin
ActiveComPort[CurrentPort] := nil;
FreeMemCheck(P, SizeOf(PortRec));
Exit;
end;
Flags := Options;
B := FlagIsSet(Flags, ptRaiseModemOnOpen);
if B then
ModemControl := ModemControl or (DTRMask or RTSMask);
end;
dSetModem(P, B, B);
end;
procedure dDonePort(var P : PortRecPtr);
begin
AsyncStatus := ecOk;
if P = nil then
Exit;
with P^ do
ActiveComPort[CurrentPort] := Nil;
FreeMemCheck(P, SizeOf(PortRec));
P := nil;
end;
procedure dSetUart(ComName : ComNameType; NewBase : Word; NewIrq, NewVector : Byte);
begin
end;
procedure dSetLine(P : PortRecPtr; Baud : LongInt;
Parity : ParityType; DataBits : DataBitType;
StopBits : StopBitType);
var
ParityB, StopBitsB, DataBitsB, BaudB : Byte;
begin
AsyncStatus := ecOk;
with P^ do
begin
case Parity of
NoParity : ParityB := 0;
OddParity : ParityB := 1;
EvenParity : ParityB := 2;
else
dGotError(P, epFatal+ecInvalidParity);
Exit;
end;
case StopBits of
1 : StopBitsB := 0;
2 : StopBitsB := 1;
else
dGotError(P, epFatal+ecOutOfRange);
Exit;
end;
case DataBits of
5 : DataBitsB := 0;
6 : DataBitsB := 1;
7 : DataBitsB := 2;
8 : DataBitsB := 3;
else
dGotError(P, epFatal+ecOutOfRange);
Exit;
end;
if Baud > 57600 then
begin
if Baud = 76800 then
BaudB := $0B
else if Baud = 115200 then
BaudB := $0C
else
begin
dGotError(P, epFatal+ecInvalidBaudRate);
Exit;
end;
end
else
case Word(Baud) of
50 : BaudB := $0D;
75 : BaudB := $0E;
110 : BaudB := $00;
134 : BaudB := $0F;
150 : BaudB := $01;
200 : BaudB := $10;
300 : BaudB := $02;
600 : BaudB := $03;
1200 : BaudB := $04;
1800 : BaudB := $11;
2400 : BaudB := $05;
4800 : BaudB := $06;
9600 : BaudB := $07;
19200 : BaudB := $08;
38400 : BaudB := $09;
57600 : BaudB := $0A;
else
dGotError(P, epFatal+ecInvalidBaudRate);
Exit;
end;
asm
les di,P
mov dl,es:[di].PortRec.PortName
xor dh,dh
mov ah,$04
mov al,$00
mov bh,ParityB
mov bl,StopBitsB
mov ch,DataBitsB
mov cl,BaudB
int $14
les di,P
mov es:[di].PortRec.ModemStatus,al
mov es:[di].PortRec.LineStatus,ah
end;
CurBaud := Baud;
CurParity := Parity;
CurDataBits := DataBits;
CurStopBits := StopBits;
end;
end;
procedure dGetLine(P : PortRecPtr; var Baud : LongInt;
var Parity : ParityType;
var DataBits : DataBitType;
var StopBits : StopBitType;
FromHardware : Boolean);
var
ParityB, StopB, DataB, BaudB : Byte;
begin
AsyncStatus := ecOk;
with P^ do
if not FromHardware then
begin
Baud := CurBaud;
Parity := CurParity;
DataBits := CurDataBits;
StopBits := CurStopBits;
end
else
begin
asm
les di,P
mov dl,es:[di].PortRec.PortName
xor dh,dh
mov ah,$0C
int $14
mov ParityB,bh
mov StopB,bl
mov DataB,ch
mov BaudB,cl
end;
case ParityB of
$00 : Parity := NoParity;
$01 : Parity := OddParity;
$02 : Parity := EvenParity;
end;
case StopB of
$00 : StopBits := 1;
$01 : StopBits := 2;
end;
case DataB of
$00 : DataBits := 5;
$01 : DataBits := 6;
$02 : DataBits := 7;
$03 : DataBits := 8;
end;
case BaudB of
$00 : Baud := 110;
$01 : Baud := 150;
$02 : Baud := 300;
$03 : Baud := 600;
$04 : Baud := 1200;
$05 : Baud := 2400;
$06 : Baud := 4800;
$07 : Baud := 9600;
$08 : Baud := 19200;
$09 : Baud := 38400;
$0A : Baud := 57600;
$0B : Baud := 76800;
$0C : Baud := 115200;
$0D : Baud := 50;
$0E : Baud := 75;
$0F : Baud := 134;
$10 : Baud := 200;
$11 : Baud := 1800;
end;
CurBaud := Baud;
CurParity := Parity;
CurDataBits := DataBits;
CurStopBits := StopBits;
end;
end;
procedure dSetModem(P : PortRecPtr; DTR, RTS : Boolean); assembler;
asm
mov AsyncStatus,ecOk
les di,P
mov dl,es:[di].PortRec.PortName
xor dh,dh
mov ah,$05
mov al,$01
mov bl,0
cmp Dtr,0
je @1
or bl,DtrMask
@1:
cmp Rts,0
je @2
or bl,RtsMask
@2:
int $14
end;
procedure dGetModem(P : PortRecPtr; var DTR, RTS : Boolean); assembler;
asm
mov AsyncStatus,ecOk
les di,P
mov dl,es:[di].PortRec.PortName
xor dh,dh
mov ah,$05
mov al,$00
int $14
les di,P
mov es:[di].PortRec.LineStatus,ah
mov es:[di].PortRec.ModemStatus,al
mov es:[di].PortRec.ModemControl,bl
mov al,bl
and al,DtrMask
cmp al,DtrMask
mov al,0
jne @1
inc al
@1:
les di,Dtr
mov es:[di],al
mov al,bl
and al,RtsMask
cmp al,RtsMask
mov al,0
jne @2
inc al
@2:
les di,Rts
mov es:[di],al
end;
procedure dGetChar(P : PortRecPtr; var C : Char);
label
GotError;
begin
if dCharReady(P) then
begin
asm
les di,P
mov dl,es:[di].PortRec.PortName
xor dh,dh
mov ah,$02
int $14
cmp ah,$80
je GotError
les di,C
mov byte ptr es:di,al
les di,P
mov es:[di].PortRec.LineStatus,ah
end;
with P^ do
begin
if LineStatus and OverrunErrorMask = OverrunErrorMask then
AsyncStatus := ecOverrunError
else if LineStatus and ParityErrorMask = ParityErrorMask then
AsyncStatus := ecParityError
else if LineStatus and FramingErrorMask = FramingErrorMask then
AsyncStatus := ecFramingError
else
AsyncStatus := ecOk;
if AsyncStatus <> ecOk then
begin
LineStatus := LineStatus and not (OverrunErrorMask or ParityErrorMask or FramingErrorMask);
dGotError(P, epNonFatal+AsyncStatus);
end;
end;
{$IFDEF Tracing}
if TracingOn then
AddTraceEntry('R', C);
{$ENDIF}
Exit;
GotError:
C := #$FF;
dGotError(P, epNonFatal+ecTimeout);
end
else
dGotError(P, epNonFatal+ecBufferIsEmpty);
end;
procedure dPeekChar(P : PortRecPtr; var C : Char; PeekAhead : Word);
label
GotError;
begin
if PeekAhead > 1 then
begin
dGotError(P, epNonFatal+ecInvalidArgument);
Exit;
end;
asm
les di,P
mov dl,es:[di].PortRec.PortName
xor dh,dh
mov ah,$08
int $14
cmp ah,$FF
je GotError
les di,C
mov byte ptr es:[di],al
end;
AsyncStatus := ecOk;
Exit;
GotError:
C := #$FF;
dGotError(P, epNonFatal+ecBufferIsEmpty);
end;
procedure dPutChar(P : PortRecPtr; C : Char);
label
GotError;
begin
asm
les di,P
mov dl,es:[di].PortRec.PortName
xor dh,dh
mov ah,$01
mov al,C
int $14
cmp ah,$80
je GotError
les di,P
mov es:[di].PortRec.LineStatus,ah
end;
AsyncStatus := ecOk;
{$IFDEF Tracing}
if TracingOn then
AddTraceEntry('T', C);
{$ENDIF}
Exit;
GotError:
dGotError(P, epNonFatal+ecBufferIsFull);
end;
procedure dStartTransmitter(P : PortRecPtr);
begin
end;
function dCharReady(P : PortRecPtr) : Boolean;
begin
dCharReady := CharReadyPtr^ = $FF;
end;
function dTransReady(P : PortRecPtr) : Boolean; assembler;
asm
les di,P
mov dl,es:[di].PortRec.PortName
xor dh,dh
mov ah,$12
int $14
cmp ax,0
je @1
mov al,1
@1:
end;
procedure dSendBreak(P : PortRecPtr); assembler;
asm
mov AsyncStatus,ecOk
les di,P
mov dl,es:[di].PortRec.PortName
xor dh,dh
mov ah,$07
mov al,$00
int $14
cmp ah,0
je @1
mov AsyncStatus,ecCCBTimeOut
@1:
end;
function dGetLineStatusDirect(P : PortRecPtr) : Byte; assembler;
asm
mov AsyncStatus,ecOk
les di,P
mov dl,es:[di].PortRec.PortName
xor dh,dh
mov ah,$03
int $14
les di,P
mov es:[di].PortRec.LineStatus,ah
mov al,ah
end;
procedure dActivatePort(P : PortRecPtr; Restore : Boolean);
begin
dGotError(P, epNonFatal+ecNotSupported);
end;
procedure dDeactivatePort(P : PortRecPtr; Restore : Boolean);
begin
dGotError(P, epNonFatal+ecNotSupported);
end;
procedure dSavePort(P : PortRecPtr; var PSR);
begin
dGotError(P, epNonFatal+ecNotSupported);
end;
procedure dRestorePort(P : PortRecPtr; var PSR);
begin
dGotError(P, epNonFatal+ecNotSupported);
end;
procedure dGotError(P : PortRecPtr; StatusCode : Word);
begin
AsyncStatus := StatusCode;
with P^ do
begin
if @ErrorProc <> @NoErrorProc then
ErrorProc(ErrorData, StatusCode);
if ProtocolActive then
AsyncStatus := AsyncStatus mod 10000;
end;
end;
procedure ActivateApDigi;
begin
{$IFNDEF UseOOP}
InitPort := dInitPort;
InitPortKeep := dInitPortKeep;
DonePort := fDonePort;
SetLine := dSetLine;
GetLine := dGetLine;
SetModem := dSetModem;
GetModem := dGetModem;
GetChar := dGetChar;
PeekChar := dPeekChar;
PutChar := dPutChar;
StartTransmitter := dStartTransmitter;
CharReady := dCharReady;
TransReady := dTransReady;
SendBreak := dSendBreak;
ActivatePort := dActivatePort;
DeactivatePort := dDeactivatePort;
SavePort := dSavePort;
RestorePort := dRestorePort;
GotError := dGotError;
{$ENDIF}
SetUart := dSetUart;
end;
begin
{$IFDEF AutoDeviceInit}
ActivateApUart;
{$ELSE}
SetUart := dSetUart;
{$ENDIF}
AnsiOutput := dPutChar;
end.